Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / Ctl < prev next >

Wrap

Text File | 1995-11-26 | 11.1 KB | 427 lines | [TEXT/MSET]

\ Control support. Mops version. \ Nov 90 Added Bob Loewenstein's improvements \ Nov 91 Controls now owned by views, not windows \ May 92 "New-style" controls \ Sept 93 mrh Controls are now views need view \ With Mops 2.4 we are changing controls yet again - although hopefully \ without affecting existing code (much). \ A control is now a subclass of view. In other respects it is more or less \ what TitledCtl was in Mops 2.3. This means that the original Control class \ has now gone for good - I hope everyone has already changed over to the \ new scheme, since hardly any changes will be needed. The main change \ is that now we don't set the viewRect directly - method SetViewRect: \ doesn't even exist any longer. Instead you use setBounds: and setJust:. \ See the comments in file View. \ We always need to refer to controls with a GrafPort-relative coordinate \ origin. This is because the system keeps a copy of the controls Rect \ in its own data structure (which the control handle points to), and uses \ this in FindControl. Thus in our DRAW: method here we have to reset the \ origin (the CallFirst code will have set it so the top left of the viewRect \ is (0, 0), which we usually want for views, but not here). \ control types: 0 constant BUTTONID 1 constant CHECKID 2 constant RADIOID 16 constant VSID \ control part codes: 10 constant INBUTTON \ simple button 11 constant INCHECKBOX \ check box or radio button 129 constant INTHUMB 20 constant INUPBUTTON \ up arrow in scroll bar 21 constant INDOWNBUTTON \ down arrow 22 constant INPAGEUP 23 constant INPAGEDOWN 8 constant USEWFONT \ Add to ID if title in application font variable TheCTL \ used for FindControl call 0 value ThisCTL \ holds addr of control just clicked on : TWIDTH \ ( addr len -- width ) \ Returns width of string in current font str255 >r word0 r> call StringWidth word0 ; \ CtlProc is the procedure to be executed when a control is being tracked. \ Our CLICK: method will have put the control object's addr in thisCtl. \ The system passes us the control handle, but what we really need is the \ object's addr so we just NIP the handle. : CtlEXEC \ ( part# -- ) exec: [ thisCtl ] ; :proc CtlPROC \ ( ^ctl int:part -- ) word0 nip ctlExec ;proc \ ====================== \ Control is the basic control class. :class CONTROL super{ view } record { int PROCID int RESID handle CTLHNDL int MyVALUE int TitleLen 32 bytes TITLE } :m PUTRESID: \ ( resID -- ) put: resID ;m :m HANDLE: \ ( -- ctlhndl ) get: ctlHndl ;m :m EXEC: \ ( part# -- ) performs action for control IF exec: clickHndlr THEN ;m :m HIDE: get: Ctlhndl call HideControl ;m :m SHOW: get: Ctlhndl call ShowControl ;m :m PUT: { theVal -- } \ Sets the ctl value. get: alive? IF addr: viewRect call ClipRect theVal get: ctlHndl swap makeint call SetCtlValue THEN theVal put: myValue ;m :m GET: \ ( -- val ) Some ctls may need original value, \ e.g. scroll bar get: alive? get: enabled? and IF word0 get: ctlHndl call getCtlValue word0 dup put: myValue \ may have been different, e.g. on a \ scroll bar thumb drag ELSE get: myValue THEN ;m :m MOVED: { \ oldL oldT oldR oldB newL newT newR newB -- } get: viewRect -> oldB -> oldR -> oldT -> oldL update: viewRect \ Old ctl posn must be redrawn bounds>viewRect: self get: viewRect -> newB -> newR -> newT -> newL nil?: ctlHndl NIF oldL newL <> oldT newT <> or oldR newR <> or oldB newB <> or IF update: viewRect \ whatever was behind must be redrawn hide: self get: ctlHndl newR newL - newB newT - pack call SizeControl get: ctlHndl newL newT pack call MoveControl show: self addr: viewRect call ValidRect THEN THEN childrenMoved: self \ Hmmm - should a control have children? ;m \ NEW: ( -- ) calls the Toolbox to fire up the control. \ When to call new: super ? If we do it at the start, child controls \ will be drawn first which isn't what we want. If we do it at the end, \ bounds>viewrect won't have been done so the viewrect won't be valid. \ So we'd better not do it at all, but completely override. :m NEW: setupNew: super 0 \ for return handle window: self addr: viewRect addr: title get: titleLen str255 w 256 \ visible - use 0 for invisible word0 word0 w 1 int: procid \ initial value, min, max, procID 0 \ initial refCon - we don't use it call NewControl put: ctlHndl get: myValue put: self windupNew: self ;m :m GETNEW: { theView -- } \ Uses a resource. setupNew: self 0 int: resID window: self call GetNewControl put: ctlHndl get: myValue put: self windupNew: self ;m :m DRAW: (draw): super 0 call SetOrigin addr: viewRect call ClipRect get: ctlHndl call Draw1Control ;m :m CLICK: { \ svClickHndlr part ^ctl action1 action2 x y -- b } \ Returns true if we've handled the click. A gotcha here is that \ we need to call click: super so that View can check if the click \ is really for us, but View mustn't execute the click handler since \ the standard action for controls is that the click only counts if \ the mouse is still in the control at mouse-up (TrackControl handles \ this). We therefore remove the click handler while calling new: super, \ then put it back! get: clickHndlr -> svClickHndlr ['] null put: clickHndlr \ Don't want View to execute the clickHndlr click: super \ Do the standard View stuff first svClickHndlr put: clickHndlr NIF false EXIT THEN \ Click wasn't for us - get out \ OK, we know the click was on this control, but we still need to call \ FindControl to get the right part code, and TrackControl to do any \ necessary tracking. ^base -> thisCtl \ For the TrackControl :proc routine word0 mpoint get: ^myWind theCtl call FindControl word0 -> part theCtl @ -> ^ctl \ ctl handle ^ctl get: ctlHndl <> \ really, they ought to be the same IF false EXIT THEN \ if not, we just return false \ (any better ideas?) part CASE[ inThumb ], [ inCheckBox ], [ inButton ]=> \ we only execute these after mouseUp - 0 -> action1 \ there's no action while mouse down. For \ this case we have to pass a toolBox NIL \ to TrackControl (i.e. zero) ['] ctlExec -> action2 DEFAULT=> drop ['] ctlproc -> action1 ['] drop -> action2 ]CASE ^ctl IF addr: viewRect call ClipRect \ so hiliting shows up! word0 ^ctl mpoint action1 call TrackControl word0 action2 execute true ELSE false THEN ;m :m HILITE: { hiliteState -- } \ Hilites a part or entire control get: alive? 0EXIT addr: viewRect call ClipRect get: ctlHndl hiliteState makeint call HiliteControl addr: viewRect call ValidRect ;m \ Otherwise it can get drawn twice, such as if when a window \ is activated it also gets uncovered, there'll be an update \ event coming. :m DISABLE: 255 hilite: self false put: enabled? ;m :m ENABLE: 0 hilite: self true put: enabled? ;m :m SETTITLE: \ ( addr len -- ) 32 min dup put: titleLen addr: title swap cmove nil?: ctlHndl NIF addr: title get: titleLen str255 get: ctlHndl swap call setCTitle THEN ;m :m GETTITLE: \ ( -- addr len ) addr: title get: titleLen ;m :m RELEASE: get: ctlHndl call DisposControl nilH put: ctlHndl release: super ;m :m CLASSINIT: \ Sets default control to a standard button classinit: super buttonID put: resID ['] null setClick: self clear: titleLen ;m ;class \ Class TitledCtl just adds a convenient INIT: method for setting up a control \ with a title, where the width of the control's rect is determined by what the \ title is. We assume the font will be Chicago and the height of the control \ is 20. Override as necessary. :class TITLEDCTL super{ control } \ INIT: ( x y addr len -- ) sets up the control with a title. \ x and y are the initial top left Bounds values (using whatever justification \ is in effect). (addr len) gives the title. :m INIT: { x y addr len \ titleWidth -- } len 32 min -> len len put: titleLen addr addr: title len cmove addr len tWidth -> titleWidth x y x titleWidth + 20 + y 20 + setBounds: self ;m ;class :class BUTTON super{ titledCtl } ;class :class CHECKBOX super{ titledCtl } :m CLASSINIT: classinit: super checkID put: procID ;m ;class :class RADIOBUTTON super{ titledCtl } :m CLASSINIT: classinit: super radioID put: procID ;m ;class \ VSCROLL is the class for vertical scroll bars. HSCROLL is a subclass \ to be used for horizontal scroll bars. \ Default handlers for clicks in scroll bar arrows: : LNUP get: [ thisCtl ] 1- put: [ thisCtl ] ; : LNDN get: [ thisCtl ] 1+ put: [ thisCtl ] ; :class VSCROLL super{ control } record { int MINVAL int MAXVAL bool HORIZ? \ True if this is really \ a horizontal scroll bar. } 5 ordered-col PARTS 5 x-array ACTIONS :m ACTIONS: \ ( up dn pgUp pgDn thumb 5 -- ) \ Loads the actions for the parts of the scroll bar, from \ the given xt list. put: actions clear: parts 129 23 22 21 20 5 FOR add: parts NEXT ;m :m EXEC: \ ( part# -- ) Performs action for part no. indexOf: parts IF exec: actions THEN ;m :m PUT: get: maxVal min get: minVal max put: super ;m :m PUTMAX: { n -- } n put: maxVal get: alive? 0EXIT get: ctlHndl n makeint call SetMaxCtl ;m :m PUTMIN: { n -- } n put: minVal get: alive? 0EXIT get: ctlHndl n makeint call SetMinCtl ;m :m PUTRANGE: \ ( lo hi -- ) putMax: self putMin: self ;m :m INIT: { left top len -- } \ for convenience and backward compatibility left top get: horiz? IF left len + top 16 + ELSE left 16 + top len + THEN setBounds: self ;m :m HIDE: get: Ctlhndl call HideControl window: self call DrawGrowIcon \ Nov95 JRF properly hide scrollbar in inactive window \ In this context DrawGrowIcon will draw the scroll frame only, \ which is just what we want. ;m :m NEW: new: super get: minVal get: maxVal putRange: self ;m \ set min and max in ctlHndl :m CLASSINIT: classinit: super 16 put: procID XTS{ lnup lndn null null null } actions: self ;m ;class :class HSCROLL super{ vscroll } :m CLASSINIT: true put: horiz? classinit: super ;m ;class endload need window+ \ Testing - this sets up a view with a button and scroll bar: window+ WW \ for display view VV \ Main view button BB \ A child view which is a button vscroll VS \ Another child view which is a vert scroll bar 40 40 300 200 setBounds: vv 10 10 " Click here" init: bb parRight parTop parRight parBottom setJust: vs -36 20 -20 -10 setBounds: vs : Drawit draw: tempRect ; \ A draw handler which just draws the viewRect : DrawVV draw: vv ; \ Draw handler for fWind for test : Clicked noclip ." clicked " .id: [self] cr \ Now we expand vv a bit to check if the scroll bar moves and resizes: getBounds: vv 10 + swap 20 + swap setBounds: vv moved: vv ; : contentClick \ New content click handler for fWind click: vv drop ; ' drawit setDraw: vv ' clicked dup setclick: vv setclick: bb : GO cls bb addview: vv vs addview: vv 0 50 putRange: vs vv test: ww \ Normally done automatically from NEW: in Window+ ;